home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Toolbox classes / Ctl < prev    next >
Text File  |  1993-01-23  |  6KB  |  213 lines
  1. \ Control support.  Mops version.
  2. \ Nov 90        Added Bob Loewenstein's improvements
  3. \ Nov 91        Controls now owned by views, not windows
  4. \ May 92        "New-style" controls
  5.  
  6. \ With Mops 2.2 we are introducing a "new style" of controls.
  7. \ In line with the view philosophy, it is more logical if when NEW: or
  8. \ DRAW: is sent to a view, it sends NEW: or DRAW: to all its controls
  9. \ automatically.  This means that NEW: for all types of control should
  10. \ have the same stack effects.  Therefore we are now introducing a
  11. \ recommended way of handling controls along the lines of menus etc.
  12. \ -- i.e. with an INIT: method which sets the control up, then with NEW:
  13. \ taking only one parameter, the owning view, and firing up the control
  14. \ according to the values already set up with INIT:.
  15.  
  16. \ So as not to break existing code, we are leaving the Control class
  17. \ as is, and introducing subclasses which have this new behavior.
  18. \ These are Button, RadioButton and CheckBox, which are subclasses of
  19. \ the generic TitledCtl.  I think these classes also give a better
  20. \ factorization than we had before, where all controls apart from
  21. \ scroll bars were generic and had their types set by the procID passed
  22. \ to INIT:.  It's not normal for a control type to be changed on the fly
  23. \ -- separate classes are more natural, I think.
  24.  
  25. \ Unfortunately this has necessitated us changing vscroll and hscroll
  26. \ to the "new style", and this may require existing code to be changed.
  27. \ Sorryyy!!!!!
  28.  
  29.     0    value    ThisCtl
  30.     0    value    ThisView
  31.  
  32. : GET-CTL-OBJ    \ ( ctlhndl -- objptr )
  33.                 \ Gets ptr to ctl obj from ctl record
  34.     0 swap  call GetCRefCon  dup -> thisCtl
  35.     dup  getView: []  -> thisView  ;
  36.  
  37. : SET-CTL-OBJ    \ ( objptr ctlhndl -- )
  38.                 \ Sets ptr to ctl obj in ctl record
  39.     swap  dup -> thisCtl  call SetCRefCon  ;
  40.  
  41. : TWIDTH    \ ( addr len -- width )
  42.             \ Returns width of string in current font
  43.     str255 >r  word0  r>  call StringWidth  word0  ;
  44.  
  45.     0    constant    BUTTONID    \ control types
  46.     1    constant    CHECKID
  47.     2    constant    RADIOID
  48.    16    constant    VSID
  49.  
  50. \            ======================
  51.  
  52. \ Control is the basic control class for simple controls - buttons, etc.
  53.  
  54. :class    CONTROL      super{ object }
  55.  
  56.     int            PROCID
  57.     int            RESID
  58.     handle        CTLHNDL
  59.     dicAddr        ACTION
  60.     int            MyVALUE
  61.     ptr            ^MyVIEW
  62.  
  63. :m PUTRESID:    \ ( resID -- )
  64.     put: resID   ;m 
  65.  
  66. :m EXEC:    \ ( part# -- )  performs action for control
  67.     if  get: action  execute  then   ;m 
  68.  
  69. :m UPDATE:    \ Cause the control to be drawn
  70.     ptr: CtlHndl  8 +  call InvalRect   ;m 
  71.  
  72. :m DRAW:    ;m    \ This is for any custom drawing in subclasses.
  73.  
  74. :m HIDE:    get: Ctlhndl  call HideControl  ;m 
  75.  
  76. :m SHOW:    get: Ctlhndl  call ShowControl  ;m 
  77.  
  78. :m MOVETO:    \ ( x y -- )   Moves control to x,y location
  79.     pack  get: ctlhndl  swap   call MoveControl  ;m
  80.  
  81. :m MOVE:    moveTo: self  ;m
  82.  
  83. :m SIZE:    \ ( w h -- )   Sets width, height of control's rect
  84.     pack   get: ctlhndl  swap   call SizeControl  ;m 
  85.  
  86. :m SETSIZE:    \ ( w h -- )  Synonym for SIZE:.
  87.     size: self  ;m 
  88.  
  89. :m INIT:  ( procid -- )        put: procid  ;m 
  90.  
  91. :m SETVIEW:    \ ( ^view -- )  Use this to initialize the owning view.
  92.     put: ^myView  ;m
  93.  
  94. :m GETVIEW:    get: ^myView  ;m
  95.  
  96. :m ACTIONS:    \ ( xt -- )  Sets the action for this control
  97.     put: action  ;m 
  98.  
  99. :m PUT:  { theVal -- }    \ Sets the ctl value.
  100.     get: ^myView  enabled?: **
  101.     if  theVal  get: ctlHndl  swap makeint  call SetCtlValue  then
  102.     theVal  put: myValue  ;m 
  103.  
  104. :m GET:        \ ( -- val )  Some ctls may need original value,
  105.         \        e.g. scroll bar
  106.     get: ^myView  enabled?: **
  107.     if    word0  get: ctlHndl  call getCtlValue  word0
  108.     else    get: myValue
  109.     then  ;m 
  110.  
  111. private
  112. :m  (SETUP):  { theView -- }
  113.     ^base  get: ctlHndl  set-ctl-obj  initFont
  114.     theView  put: ^myView  get: myValue  put: self   ;m 
  115. public
  116.  
  117. \ NEW:    (x y addr len theView)   fires up the control.   x, y is the top left coordinate relative to the bounding rectangle of the containing view.
  118.  
  119. :m NEW:  { x y addr len theView \ titleWidth -- }
  120.     getRect: theView  2drop    \ ( left top )
  121.     ++> y   ++> x            \ Make x,y rel to grafport as reqd
  122.     get: procID  8 and        \ window font if true
  123.     nif  0 tFont 12 tSize  ( Chicago 12 )  then
  124.     addr len tWidth  -> titleWidth
  125.     x  y   x  titleWidth +  17 +   y 17 +   put: tempRect
  126.     0  window: theView  addr: tempRect  addr len str255
  127.     w 256  word0  word0  w 1  int: procid  ^base
  128.     call NewControl   put: ctlHndl
  129.     theView  (setup): self  ;m 
  130.  
  131. :m GETNEW:  { theView -- }
  132.         \ Creates a new control on the heap, using a resource.
  133.     0  int: resID  window: theView
  134.     call GetNewControl  put: ctlHndl
  135.     theView  (setup): self  ;m 
  136.  
  137. :m HANDLE:    \ ( -- ctlhndl )
  138.     get: ctlHndl  ;m 
  139.  
  140. :m HILITE:    \ ( hiliteState -- )  Hilite a part or entire control
  141.     get: ctlHndl  swap  makeInt
  142.     call HiliteControl  ;m 
  143.  
  144. :m DISABLE:    -1  hilite: self  ;m 
  145. :m ENABLE:     0  hilite: self  ;m 
  146.  
  147. :m GETRECT:    \ ( -- l t r b )  Stacks bounds rectangle
  148.     ptr: ctlHndl  8 +  get: rect  ;m 
  149.  
  150. :m SETTITLE:    \ ( addr len -- )
  151.     str255  get: ctlHndl  swap  call setCTitle  ;m 
  152.  
  153. :m GETTITLE:    \ ( -- addr len )
  154.     get: ctlhndl  pad  call getCTitle  pad count  ;m 
  155.  
  156. :m CLOSE:    get: ctlHndl  call DisposControl  ;m 
  157.  
  158. :m RELEASE:    close: self  ;m     \ Standard Mops "shutdown" method name
  159.  
  160.  
  161. :m CLASSINIT:    \ Sets default control to a standard button
  162.     buttonID  init: self  ['] null  actions: self   ;m 
  163.  
  164. ;class
  165.  
  166. :class    TITLEDCTL  super{  control  }
  167.  
  168.     int        TOP
  169.     int        LEFT
  170.     int        TitleLen
  171. 32    bytes    TITLE
  172.  
  173. \ INIT:  sets up the control with a title.   x, y is the top left coordinate
  174. \ relative to the bounding rectangle of the containing view.  (addr len)
  175. \ gives the title.
  176.  
  177. :m INIT:        \ ( x y addr len -- )
  178.     32 min  dup put: titleLen  addr: title  swap  cmove
  179.     put: top  put: left  ;m
  180.  
  181. :m NEW:     { theView -- }
  182.     get: left   get: top
  183.     addr: title  get: titleLen  theView  new: super  ;m
  184.  
  185. ;class
  186.  
  187. :class    BUTTON    super{ titledCtl }
  188. ;class
  189.  
  190. :class    CHECKBOX  super{ titledCtl }
  191.   :m CLASSINIT:    classinit: super   checkID  put: procID  ;m
  192. ;class
  193.  
  194. :class    RADIOBUTTON    super{ titledCtl }
  195.   :m CLASSINIT:    classinit: super  radioID  put: procID  ;m
  196. ;class
  197.  
  198.  
  199. variable    THECTL
  200.  
  201. \ control part codes
  202.  
  203.   10    constant  INBUTTON        \ simple button
  204.   11    constant  INCHECKBOX        \ check box or radio button
  205.  129    constant  INTHUMB
  206.   20    constant  INUPBUTTON        \ up arrow in scroll bar
  207.   21    constant  INDOWNBUTTON    \ down arrow
  208.   22    constant  INPAGEUP
  209.   23    constant  INPAGEDOWN
  210.  
  211.  
  212.    8    constant  USEWFONT    \ Add to ID if title in application font
  213.